
 {Sample code for the Rectangle procedure.}

uses Crt, Graph,dos;

const   color=white;            { maxx 639  maxy 479 }
        colorbk=blue;
        wallx=8*60;
        wally=8*5;
        bug_long=20000;
        tq=8;
        bb='*';
        up=1;
        left=2;
        down=3;
        right=4;
        speedchar:set of char=['a','s'];

var
    x,y,len,number_eat,v:integer;
    foodx,foody,inforx,infory,speedx,speedy,scorex,scorey:Integer;
    eatx,eaty,lenx,leny:integer;
    s_score,s_number,s_len,s_speed:string;
    bug:array[1..bug_long] of integer;
    die,nodie:boolean;
    score:longint;
    ch:char;



procedure egadriver;external;
{$L e:\dd.obj}


procedure draw(x,y:integer);
 begin
   moveto(x,y);
   outtext(bb);
 end;

procedure quwei(x,y:integer);
 const n=100;
 var i,j:integer;
     s:string;
 begin
   setcolor(colorbk);
   moveto(x,y);
   outtext('*');
   setcolor(color);
 end;

procedure first_readln;
  begin
    moveto(85,tq*22);
    setcolor(green);
    SetTextStyle(DefaultFont, HorizDir, 2);
    outtext('Press any key to start.');
    setcolor(colorbk);
    readkey;
    moveto(85,tq*22);
    outtext('Press any key to start.');
    SetTextStyle(DefaultFont, HorizDir, 1);
    setcolor(color);

  end;
procedure last_readln;
  begin
    moveto(85,tq*20);
    setcolor(green);
    SetTextStyle(DefaultFont, HorizDir, 2);
    outtext('Press any key to exit.');
    moveto(85,tq*15);
    outtext('Sorry you are dead.');
    readkey;

   { setcolor(colorbk);
    moveto(100,tq*20);
    outtext('Press Enter to exit.');
    SetTextStyle(DefaultFont, HorizDir, 1);
    setcolor(color);     }

  end;

procedure writenum(a,b:integer;shu:integer);
  var s:string;
  begin
    str(shu,s);
    moveto(a,b);
    outtext(s);
  end;


procedure graph_init;
  var errorcode,GraphDriver, GraphMode: Integer;
  begin
    registerbgidriver(@egadriver);
    GraphDriver := Detect;
    InitGraph(GraphDriver, GraphMode, ' ');
    errorcode:=Graphresult;
    if errorcode<> grOk then
      begin
        writeln('Init the graph error ! Error code :',errorcode);
        Halt(1);
      end;
    setbkcolor(colorbk);
    setcolor(color);
    rectangle(1,1,getmaxx,getmaxy);
  end;

procedure wall_init;
  begin
    line(0,wally,getmaxx,wally);
    line(wallx,wally,wallx,getmaxy);
  end;

procedure about_init;
  var a,b,distance:integer;
  begin
    distance:=tq*2;
    a:=(getmaxx div 2)-tq*17;
    moveto(a,tq+3);
    SetTextStyle(DefaultFont, HorizDir, 2);
    outtext('Eating Snake');
    SetTextStyle(DefaultFont, HorizDir, 1);
    moveto(a+189,tq*3);
    outtext('  Tang Qiao 2001.11.');
    moveto(inforx,infory);
    outtext('Your spead: ');speedx:=getx;speedy:=gety;

    inc(infory,distance);
    moveto(inforx,infory);
    outtext('Eat number: ');eatx:=getx;eaty:=gety;

    inc(infory,distance);
    moveto(inforx,infory);
    outtext('Your length:');lenx:=getx;leny:=gety;


    inc(infory,distance);
    moveto(inforx,infory);
    outtext('Total score:');scorex:=getx;scorey:=gety;

    inc(infory,distance*5);
    moveto(inforx,infory);
    outtext('Help information:');
    inc(infory,distance);
    moveto(inforx,infory);
    outtext('  P --- Pause');

    inc(infory,distance);
    moveto(inforx,infory);
    outtext('  A --- Faster');

    inc(infory,distance);
    moveto(inforx,infory);
    outtext('  S --- Slower');

    inc(infory,distance*6);
    moveto(inforx,infory);
    outtext('Thank you');
    inc(infory,tq);
    moveto(inforx+tq*5,infory);
    outtext('for using !');
    inc(infory,distance);
    moveto(inforx,infory);
    outtext('Oicq: 21056451');
    inc(infory,distance);
    moveto(inforx,infory);
    outtext('E-mail:');
    inc(infory,tq);
    moveto(inforx+tq*2,infory);
    outtext('tang19840903@');
    inc(infory,tq);
    moveto(inforx+tq*2,infory);
    outtext('   sina.com');

    inc(infory,tq*3);
    moveto(inforx,infory);
    outtext('   (C)Copyright');
    inc(infory,tq);
    moveto(inforx,infory);
    outtext('TangQiao Store Room ');
  end;

procedure init(a:integer);
  var i:integer;
  begin
    inforx:=488;
    infory:=72;
    die:=false;
    nodie:=false;
    number_eat:=0;s_number:='0';
    score:=0;s_score:='0';
    v:=800;str(v,s_speed);
    len:=a;str(v,s_len);
    x:=tq*10;   { init site }
    y:=tq*20;
    fillchar(bug,sizeof(bug),0);
    for i:=1 to a do   { make the bug }
      bug[i]:=2;
    moveto(x,y);      { first draw the snake }
    for i:=1 to a do
      begin
        outtext(bb);
        inc(x,tq);
      end;
    dec(x,tq);
    ch:=#77;
    wall_init;
    about_init;
  end;

procedure write_speed(ch:char);
  var s:string;
  begin
    case ch of
      'a':begin
            if v>50 then dec(v,50);
            moveto(speedx,speedy);
            setcolor(colorbk);
            str(1000-v-50,s);
            outtext(s);
            setcolor(color);
            str(1000-v,s);
            moveto(speedx,speedy);
            outtext(s);
          end;
      's':begin
            if v<1000 then inc(v,50);
            moveto(speedx,speedy);
            setcolor(colorbk);
            str(1000-v+50,s);
            outtext(s);
            setcolor(color);
            str(1000-v,s);
            moveto(speedx,speedy);
            outtext(s);
          end;
      't':begin
            moveto(speedx,speedy);
            str(1000-v,s);
            outtext(s);
          end;
    end;
  end;

procedure write_nodie;
  var b:integer;
  begin
     b:=infory-20*tq;
      moveto(inforx,b);
           if nodie then
              begin
                outtext('Congratulation!');
                moveto(inforx,b+2*tq);
                outtext('You will not die.');
              end
                     else
              begin
                setcolor(colorbk);
                outtext('Congratulation!');
                moveto(inforx,b+2*tq);
                outtext('You will not die.');
                setcolor(color);
              end
  end;

procedure write_score;
  begin
    moveto(scorex,scorey);
    setcolor(colorbk);
    outtext(s_score);
    setcolor(color);
    str(score,s_score);
    moveto(scorex,scorey);
    outtext(s_score);
    inc(score);
  end;

procedure write_len;
  begin
    moveto(lenx,leny);
    setcolor(colorbk);
    outtext(s_len);
    setcolor(color);
    str(len,s_len);
    moveto(lenx,leny);
    outtext(s_len);
    inc(len);
  end;

procedure write_eat;
  begin
    moveto(eatx,eaty);
    setcolor(colorbk);
    outtext(s_number);
    setcolor(color);
    str(number_eat,s_number);
    moveto(eatx,eaty);
    outtext(s_number);
    inc(number_eat);
  end;

procedure food(var foodx,foody:integer);
  var k:boolean;
      i,a,b:integer;
  begin
    randomize;
    repeat
       foodx:=random(59)*tq+tq;     { 5 60 }
       foody:=random(53)*tq+6*tq;
       k:=true;
       a:=x;b:=y;
       for i:=1 to len do
         begin
            if (a=foodx)and(b=foody) then
              begin
                k:=false;
                break;
              end;
            case bug[i] of
              up:dec(b);
              left:dec(a);
              down:inc(b);
              right:inc(a);
            end;
         end;
    until k;
    moveto(foodx,foody);
    setcolor(yellow);
    outtext('*');
    setcolor(color);
  end;

procedure gameover;
  begin
    closegraph;
    halt;
  end;

procedure drawrun;
  var a,b,i:integer;
  begin
    for i:=len downto 2 do bug[i]:=bug[i-1];
      case ch of
        #72:bug[1]:=down;   { up }
        #75:bug[1]:=right;  {left}
        #80:bug[1]:=up;     {down}
        #77:bug[1]:=left;   {right}
    end;
    a:=x;
    b:=y;
    draw(a,b);
    for i:=1 to len do
      begin
        case bug[i] of
          up:dec(b,tq);
          left:dec(a,tq);
          down:inc(b,tq);
          right:inc(a,tq);
        end;
        if i<>len then
          begin
            draw(a,b);
          end
                   else
          begin
            quwei(a,b);
          end;
      end;
  end;

function fan(a:char):char;
  begin
    fan:=a;
    if (a=#72)and(ch=#80) then fan:=ch;
    if (a=#80)and(ch=#72) then fan:=ch;
    if (a=#75)and(ch=#77) then fan:=ch;
    if (a=#77)and(ch=#75) then fan:=ch;
  end;

function hit_wall:boolean;
  begin
    if (x=wallx)or(y=wally-tq)or(x=-tq)or(y=480) then hit_wall:=true
                                                   else hit_wall:=false;
  end;

function if_die(ya,yb:integer):boolean;
  var a,b,i:integer;
  begin
    a:=x;b:=y;
    for i:=1 to len-1 do
      begin
            case bug[i] of
              up:dec(b);
              left:dec(a);
              down:inc(b);
              right:inc(a);
            end;
            if (a=ya)and(b=yb) then
              begin
                if_die:=true;
                exit;
              end;
         if hit_wall then
           begin
             if_die:=true;
             exit;
           end;
      end;
    if_die:=false;
  end;

procedure happysound;
  begin
    sound(800);
    delay(50);
  end;

procedure runtimes;
  const
  days : array [0..6] of String[9] =
    ('Sunday','Monday','Tuesday',
     'Wednesday','Thursday','Friday',
     'Saturday');
var
  y, m, d, dow : Word;

  h, m1, s, hund : Word;
function LeadingZero(w : Word) : String;
var
  s : String;
begin
  Str(w:0,s);
  if Length(s) = 1 then
    s := '0' + s;
  LeadingZero := s;
end;

begin
  assign(output,'./date.ske');
  {$I-}
  reset(output);
  {$I+}
  if Ioresult<>0 then rewrite(output)
                 else append(output);
  GetTime(h,m1,s,hund);
  Write('It is now ',LeadingZero(h),':',
          LeadingZero(m1),':',LeadingZero(s),
          '.',LeadingZero(hund));
  GetDate(y,m,d,dow);
  Write('  Today is ', days[dow],', ',
          m:0, '/', d:0, '/', y:0);
  close(output);
end;

procedure runtimes2;
  begin
    append(output);
    writeln(' total score=',score);
    writeln('-----------------------------------------------------------------');
    close(output);
  end;

procedure run(var x,y:integer);
  const speedchar:set of char=['a','s'];
  var i,j:integer;
      pre:char;
 begin
   write_score;
   write_len;
   write_eat;
   v:=200;
   write_speed('t');
   first_readln;
   food(foodx,foody);
   while not die do
     begin
      while keypressed do readkey;
      delay(v);
      if keypressed then
       begin
        pre:=readkey;
        if pre=#27 then begin
                          runtimes2;
                          gameover;
                        end;
        if pre='p' then
          begin
            pre:=readkey;
            if pre='*' then
              begin
                if nodie then nodie:=false
                         else nodie:=true;
              end;
            write_nodie;
          end;
        if pre in speedchar then write_speed(pre);
        if pre=#0 then
          begin
            pre:=readkey;
            ch:=fan(pre);
            case ch of
              #72:dec(y,tq);  { up }
              #75:dec(x,tq);  {left}
              #80:inc(y,tq);  {down}
              #77:inc(x,tq);  {right}
            end;
          end
                  else
          begin
            case ch of
             #72:dec(y,tq);  { up }
             #75:dec(x,tq);  {left}
             #80:inc(y,tq);  {down}
             #77:inc(x,tq);  {right}
            end;
          end;
       end
                    else
       begin
         case ch of
             #72:dec(y,tq);  { up }
             #75:dec(x,tq);  {left}
             #80:inc(y,tq);  {down}
             #77:inc(x,tq);  {right}
         end;
       end;
       drawrun;
       write_score;

       die:=if_die(x,y);

       if (x=foodx)and(y=foody) then
         begin
           happysound;
           food(foodx,foody);
           write_len;
           write_eat;
           nosound;
         end;
       if nodie then die:=false;
     end;  { end while }
     if die then
       begin
         runtimes2;
         last_readln;
       end;
 end;

begin     {   *********** main **************  }
  runtimes;
  graph_init; { maxx 639  maxy 479 }

  init(5);
  run(x,y);
  gameover;
end.


